home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_oth / forchek1 / prsymtab.c < prev    next >
C/C++ Source or Header  |  1991-11-05  |  45KB  |  1,636 lines
  1.  
  2. /* prsymtab.c:
  3.  
  4.   Routines associated with printing of symbol table info
  5.  
  6.     Copyright (C) 1991 by Robert K. Moniot.
  7.     This program is free software.  Permission is granted to
  8.     modify it and/or redistribute it, retaining this notice.
  9.     No guarantees accompany this software.
  10.  
  11.  Shared functions defined:
  12.  
  13.   arg_array_cmp()   Compares subprogram calls with defns.
  14.   check_arglists()  Scans global symbol table for subprograms
  15.       and finds subprogram defn if it exists.
  16.   check_comlists()  Scans global symbol table for common blocks.
  17.   com_cmp_strict()   Compares lists of common variables.
  18.   debug_symtabs() Prints debugging info about symbol tables.
  19.   print_loc_symbols(curmodhash) Prints local symtab info.
  20.  
  21.  Private functions defined:
  22.   check_mixed_common() checks common for nonportable mixed type
  23.   sort_symbols()   Sorts the list of names of a given category.
  24.   swap_symptrs()   Swaps a pair of pointers.
  25.   check_flags()     Outputs messages about used-before-set etc.
  26.   print_symbols(sym_list,n,do_types) Prints symbol lists.
  27.   print_variables(sym_list,n)  Prints variable symbol table
  28. */
  29.  
  30. #include <stdio.h>
  31. #include <ctype.h>
  32. #include <string.h>
  33. #include "forchek.h"
  34. #include "symtab.h"
  35.  
  36.  
  37. PRIVATE
  38. int has_nonalnum();
  39. PRIVATE unsigned
  40. find_sixclashes(), print_variables(), print_symbols();
  41.  
  42.  
  43. PRIVATE
  44. void
  45. swap_symptrs(), sort_symbols(), check_flags(), check_mixed_common(),
  46. com_cmp_strict(), arg_array_cmp();
  47.  
  48.  
  49.  
  50. #define pluralize(n) ((n)==1? "":"s") /* singular/plural suffix for n */
  51.  
  52. #define CMP_ERR_LIMIT 3 /* stop printing errors after this many */
  53.  
  54. PRIVATE void
  55. arg_array_cmp(name,args1,args2)
  56.        /* Compares subprogram calls with definition */
  57.  char *name;
  58.  ArgListHeader *args1, *args2;
  59. {
  60.  int i,
  61.      typerr = 0,
  62.      usage_err = 0;
  63.  int  n,
  64.       n1 = args1->numargs,
  65.       n2 = args2->numargs;
  66.  ArgListElement *a1 = args1->arg_array,
  67.          *a2 = args2->arg_array;
  68.  
  69.  n = (n1 > n2) ? n2: n1;  /* n = min(n1,n2) */
  70.  
  71.  if (n1 != n2){
  72.     fprintf(list_fd,"\nSubprogram %s: varying number of arguments:",name);
  73.     fprintf(list_fd,"\n\t%s with %d argument%s in module %s line %u file %s",
  74.       args1->is_defn? "Defined":"Invoked",
  75.           n1,pluralize(n1),
  76.       args1->module->name,
  77.       args1->line_num,
  78.       args1->filename);
  79.  
  80.     fprintf(list_fd,"\n\t%s with %d argument%s in module %s line %u file %s",
  81.       args2->is_defn? "Defined":"Invoked",
  82.       n2,pluralize(n2),
  83.       args2->module->name,
  84.       args2->line_num,
  85.       args2->filename);
  86.         }
  87.  
  88.  { /* Look for type mismatches */
  89.      typerr = 0;
  90.      for (i=0; i<n; i++) {
  91.   if(a1[i].type != a2[i].type){
  92.       int t1 = datatype_of(a1[i].type),
  93.    t2 = datatype_of(a2[i].type);
  94.  
  95.    /* Allow hollerith to match integer or logical */
  96.       if( (t1 == type_HOLLERITH
  97.          && (t2 == type_INTEGER || t2 == type_LOGICAL))
  98.        || (t2 == type_HOLLERITH
  99.          && (t1 == type_INTEGER || t1 == type_LOGICAL))
  100.     && (storage_class_of(a1[i].type)==storage_class_of(a1[i].type)) )
  101.          continue;
  102.  
  103.    /* stop after limit: probably a cascade */
  104.    if(++typerr > CMP_ERR_LIMIT) {
  105.     fprintf(list_fd,"\n etc...");
  106.     break;
  107.    }
  108.  
  109.       if(typerr == 1)
  110.     fprintf(list_fd,"\nSubprogram %s:  argument data type mismatch",
  111.      name);
  112.  
  113.     fprintf(list_fd, "\n  at position %d:", i+1);
  114.     fprintf(list_fd,"\n\t%s %s %s in module %s line %u file %s",
  115.        args1->is_defn? "Dummy type": "Actual type",
  116.        type_name[t1],
  117.        class_name[storage_class_of(a1[i].type)],
  118.        args1->module->name,
  119.        args1->line_num,
  120.        args1->filename);
  121.     fprintf(list_fd,"\n\t%s %s %s in module %s line %u file %s",
  122.        args2->is_defn? "Dummy type": "Actual type",
  123.        type_name[t2],
  124.        class_name[storage_class_of(a2[i].type)],
  125.        args2->module->name,
  126.        args2->line_num,
  127.        args2->filename);
  128.       if(args1->is_defn
  129.    && storage_class_of(a1[i].type) == class_SUBPROGRAM
  130.    && storage_class_of(a2[i].type) != class_SUBPROGRAM
  131.    && datatype_of(a1[i].type) != type_SUBROUTINE
  132.    && ! a1[i].declared_external )
  133.    fprintf(list_fd,"\n\t(possibly it is an array which was not declared)");
  134.   }
  135.      }
  136.  }/* end look for type mismatches */
  137.  
  138.  
  139.    /* Check arrayness of args only if defn exists */
  140.  if( args1->is_defn ) {
  141.      int arrayness_errs = 0;
  142.      unsigned long diminfo1,diminfo2,dims1,dims2,size1,size2;
  143.  
  144.      for (i=0; i<n; i++) {
  145.        if(storage_class_of(a1[i].type) == class_VAR
  146.        && storage_class_of(a2[i].type) == class_VAR) {
  147.  
  148.    /* Allow holleriths to match arrays.  Type
  149.       match was checked above, so they will
  150.       be matching arrays of integer or logical. */
  151.       if( datatype_of(a1[i].type) == type_HOLLERITH
  152.        || datatype_of(a2[i].type) == type_HOLLERITH )
  153.          continue;
  154.  
  155.   diminfo1 = a1[i].info.array_dim;
  156.   diminfo2 = a2[i].info.array_dim;
  157.   dims1 = array_dims(diminfo1);
  158.   dims2 = array_dims(diminfo2);
  159.   size1 = array_size(diminfo1);
  160.   size2 = array_size(diminfo2);
  161. #if 0
  162. if(debug_latest){
  163. fprintf(list_fd,"\n%s arg %d: array_var=%d%d array_element=%d%d",
  164. name,i+1,
  165. a1[i].array_var,a2[i].array_var,
  166. a1[i].array_element,a2[i].array_element);
  167. fprintf(list_fd,"\nDummy dims=%ld size=%ld",dims1,size1);
  168. fprintf(list_fd,"\nActual dims=%ld size=%ld",dims2,size2);
  169. }
  170. #endif
  171.  
  172.   if( a1[i].array_var ) { /* I. Dummy arg is array */
  173.       if( a2[i].array_var ) {
  174.    if( a2[i].array_element ) {
  175.      /*   A. Actual arg is array elt */
  176.      /* Warn at novice level 1. */
  177.        if(novice_level <= 1) {
  178.     /* stop after limit: probably a cascade */
  179.     if(++arrayness_errs > CMP_ERR_LIMIT) {
  180.           fprintf(list_fd,"\n etc...");
  181.           break;
  182.     }
  183.  
  184.     if(arrayness_errs == 1)
  185.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  186.      name);
  187.  
  188.  fprintf(list_fd, "\n  at position %d:", i+1);
  189.  
  190.  fprintf(list_fd,
  191.  "\n\tDummy arg is whole array in module %s line %u file %s",
  192.        args1->module->name,
  193.        args1->line_num,
  194.        args1->filename);
  195.  fprintf(list_fd,
  196.  "\n\tActual arg is array element in module %s line %u file %s",
  197.        args2->module->name,
  198.        args2->line_num,
  199.        args2->filename);
  200.        }
  201.    }
  202.    else {
  203.      /*   B. Actual arg is whole array */
  204.      /* Warn at novice level 1 if dims
  205.       or sizes differ */
  206.  
  207.    /* size = 0 or 1 means adjustable: OK to differ */
  208.        if( novice_level <= 1 &&
  209.     ( (size1 > 1 && size2 > 1 && size1 != size2)
  210.     || (dims1 != dims2) ) ) {
  211.  
  212.     /* stop after limit: probably a cascade */
  213.     if(++arrayness_errs > CMP_ERR_LIMIT) {
  214.           fprintf(list_fd,"\n etc...");
  215.           break;
  216.     }
  217.  
  218.     if(arrayness_errs == 1)
  219.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  220.      name);
  221.  
  222.  fprintf(list_fd, "\n  at position %d:", i+1);
  223.  
  224.  fprintf(list_fd,
  225.   "\n\tDummy arg %ld dim%s size %ld in module %s line %u file %s",
  226.        dims1,pluralize(dims1),
  227.        size1,
  228.        args1->module->name,
  229.        args1->line_num,
  230.        args1->filename);
  231.  fprintf(list_fd,
  232.  "\n\tActual arg %ld dim%s size %ld in module %s line %u file %s",
  233.        dims2,pluralize(dims2),
  234.        size2,
  235.        args2->module->name,
  236.        args2->line_num,
  237.        args2->filename);
  238.  
  239.     }
  240.    }
  241.       }
  242.       else {
  243.      /*   C. Actual arg is scalar */
  244.      /* Warn in all cases */
  245.  
  246.     /* stop after limit: probably a cascade */
  247.     if(++arrayness_errs > CMP_ERR_LIMIT) {
  248.           fprintf(list_fd,"\n etc...");
  249.           break;
  250.     }
  251.  
  252.     if(arrayness_errs == 1)
  253.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  254.      name);
  255.  
  256.  fprintf(list_fd, "\n  at position %d:", i+1);
  257.  
  258.  fprintf(list_fd,
  259.  "\n\tDummy arg is array in module %s line %u file %s",
  260.        args1->module->name,
  261.        args1->line_num,
  262.        args1->filename);
  263.  fprintf(list_fd,
  264.  "\n\tActual arg is scalar in module %s line %u file %s",
  265.        args2->module->name,
  266.        args2->line_num,
  267.        args2->filename);
  268.  
  269.       }
  270.   } /* end dummy is array case */
  271.  
  272.   else {   /* II. Dummy arg is scalar */
  273.       if( a2[i].array_var ) {
  274.    if( a2[i].array_element ) {
  275.      /*   A. Actual arg is array elt */
  276.      /* OK */
  277.    }
  278.    else {
  279.      /*   B. Actual arg is whole array */
  280.      /* Warn in all cases */
  281.  
  282.     /* stop after limit: probably a cascade */
  283.     if(++arrayness_errs > CMP_ERR_LIMIT) {
  284.           fprintf(list_fd,"\n etc...");
  285.           break;
  286.     }
  287.  
  288.     if(arrayness_errs == 1)
  289.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  290.      name);
  291.  
  292.  fprintf(list_fd, "\n  at position %d:", i+1);
  293.  
  294.  fprintf(list_fd,
  295.  "\n\tDummy arg is scalar in module %s line %u file %s",
  296.        args1->module->name,
  297.        args1->line_num,
  298.        args1->filename);
  299.  fprintf(list_fd,
  300.  "\n\tActual arg is whole array in module %s line %u file %s",
  301.        args2->module->name,
  302.        args2->line_num,
  303.        args2->filename);
  304.    }
  305.       }
  306.       else {
  307.      /*   C. Actual arg is scalar */
  308.      /* OK */
  309.       }
  310.  
  311.  
  312.   } /* end dummy is scalar case */
  313.  
  314.        } /* end if class_VAR */
  315.      }/* end for (i=0; i<n; i++) */
  316.  }/* if( args1->is_defn ) */
  317.  
  318.  
  319.    /* Check usage of args only if defn exists */
  320.  if(usage_check && args1->is_defn) {
  321.      usage_err = 0;
  322.  
  323.      for (i=0; i<n; i++) {
  324.   int nonlvalue_out = (a1[i].assigned_flag && !a2[i].is_lvalue),
  325.       nonset_in = (a1[i].used_before_set && !a2[i].set_flag);
  326.  
  327. #if 0
  328. if(debug_latest) {
  329. fprintf(list_fd,
  330. "\nUsage check: %s[%d] dummy asgnd %d ubs %d  actual lvalue %d set %d",
  331. args1->module->name,
  332. i+1,
  333. a1[i].assigned_flag,
  334. a1[i].used_before_set,
  335. a2[i].is_lvalue,
  336. a2[i].set_flag);
  337. }
  338. #endif
  339.  
  340.   if(nonlvalue_out || nonset_in) {
  341.  
  342.    /* stop after limit: probably a cascade */
  343.       if(++usage_err > CMP_ERR_LIMIT) {
  344.     fprintf(list_fd,"\n etc...");
  345.     break;
  346.       }
  347.       if(usage_err == 1)
  348.   fprintf(list_fd,"\nSubprogram %s:  argument usage mismatch",
  349.      name);
  350.  
  351.   fprintf(list_fd, "\n  at position %d:", i+1);
  352.  
  353.       if(nonlvalue_out) {
  354.   fprintf(list_fd,
  355.  "\n\tDummy arg is modified in module %s line %u file %s",
  356.        args1->module->name,
  357.        args1->line_num,
  358.        args1->filename);
  359.   fprintf(list_fd,
  360.  "\n\tActual arg is const or expr in module %s line %u file %s",
  361.        args2->module->name,
  362.        args2->line_num,
  363.        args2->filename);
  364.       }
  365.       else
  366.  
  367.       if(nonset_in) {
  368.   fprintf(list_fd,
  369.  "\n\tDummy arg used before set in module %s line %u file %s",
  370.        args1->module->name,
  371.        args1->line_num,
  372.        args1->filename);
  373.   fprintf(list_fd,
  374.  "\n\tActual arg not set in module %s line %u file %s",
  375.        args2->module->name,
  376.        args2->line_num,
  377.        args2->filename);
  378.       }
  379.   }
  380.      }
  381.  }/*end if(usage_err && args->is_defn) */
  382.  
  383. }/* arg_array_cmp */
  384.  
  385.  
  386. void
  387. check_arglists() /* Scans global symbol table for subprograms */
  388. {                       /* and finds subprogram defn if it exists */
  389.  unsigned i;
  390.  ArgListHeader *defn_list, *alist;
  391.  for (i=0; i<glob_symtab_top; i++){
  392.      if(storage_class_of(glob_symtab[i].type) != class_SUBPROGRAM)
  393.   continue;
  394.      if((alist=glob_symtab[i].info.arglist) == NULL){
  395. /*       if(ext_def_check) {
  396. **  fprintf(list_fd,"\nSubprogram %s never defined",
  397. **   glob_symtab[i].name);
  398. **  if(!glob_symtab[i].used_flag)
  399. **      fprintf(list_fd," nor invoked");
  400. **       }
  401. */
  402.       fprintf(list_fd,"\nOops--global symbol %s has no argument lists",
  403.        glob_symtab[i].name);
  404.      }
  405.      else{ /* alist != NULL */
  406.   int num_defns= 0;
  407.   ArgListHeader *list_item;
  408.  
  409.    /* use 1st invocation instead of defn if no defn */
  410.   defn_list = alist;
  411.  
  412.   list_item = alist;
  413.   while(list_item != NULL){
  414.       if(list_item->is_defn){
  415.    if(ext_def_check && num_defns > 0) {/* multiple defn */
  416.        if(num_defns == 1) {
  417.     fprintf(list_fd,"\nSubprogram %s multiply defined:",
  418.     glob_symtab[i].name);
  419.     fprintf(list_fd,"\n\tin module %s line %u file %s",
  420.     defn_list->module->name,
  421.     defn_list->line_num,
  422.     defn_list->filename);
  423.        }
  424.    fprintf(list_fd,"\n\tin module %s line %u file %s",
  425.     list_item->module->name,
  426.     list_item->line_num,
  427.     list_item->filename);
  428.    }
  429.  
  430.    ++num_defns;
  431.    defn_list = list_item; /* Use last defn found */
  432.       }
  433.       else { /* ! list_item->is_defn */
  434.     /* Here treat use as actual arg like call */
  435.    if(list_item->is_call || list_item->actual_arg){
  436.         /* Use last call as defn */
  437.      if(!defn_list->is_defn) /* if no defn found */
  438.        defn_list = list_item;
  439.           }
  440.       }
  441.  
  442.       list_item = list_item->next;
  443.   }
  444.   if(num_defns == 0){
  445.      if(ext_def_check) {
  446.     fprintf(list_fd, "\nSubprogram %s never defined",
  447.        glob_symtab[i].name);
  448.    if(!glob_symtab[i].used_flag)
  449.     fprintf(list_fd," nor invoked");
  450.  
  451.     fprintf(list_fd, "\n\t%s in module %s line %u file %s",
  452.        (defn_list->external_decl)?"declared":"invoked",
  453.        defn_list->module->name,
  454.        defn_list->line_num,
  455.        defn_list->filename);
  456.    /* Warn if it seems it may just be an array they
  457.       forgot to declare */
  458.         if(defn_list->numargs != 0
  459.     && datatype_of(defn_list->type) != type_SUBROUTINE
  460.     && ! glob_symtab[i].declared_external) {
  461.    if(novice_level <= 3)
  462.     fprintf(list_fd,"\n\t(possibly it is an array which was not declared)");
  463.         }
  464.      }
  465.   }
  466.   else{ /* num_defns != 0 */
  467.       if(!glob_symtab[i].used_flag
  468.          && datatype_of(glob_symtab[i].type) != type_BLOCK_DATA
  469.          && !glob_symtab[i].library_module) {
  470.    fprintf(list_fd,"\nSubprogram %s never invoked",
  471.     glob_symtab[i].name);
  472.     fprintf(list_fd, "\n\tdefined in module %s line %u file %s",
  473.        defn_list->module->name,
  474.        defn_list->line_num,
  475.        defn_list->filename);
  476.       }
  477.   }
  478.    /* Now check defns/invocations for consistency.  If
  479.       no defn, 1st invocation will serve.
  480.       Here treat use as actual arg like call */
  481.   if(defn_list->is_defn || !defn_list->external_decl) {
  482.     while(alist != NULL){
  483.    int typerrs = 0;
  484.    if(alist != defn_list && !alist->external_decl) {
  485.               if(alist->type != defn_list->type){
  486.     int t1 = datatype_of(defn_list->type),
  487.         t2 = datatype_of(alist->type);
  488.         if(typerrs++ == 0){
  489.    fprintf(list_fd,"\nSubprogram %s invoked inconsistently:",
  490.            glob_symtab[i].name);
  491.    fprintf(list_fd,"\n\t%s type %s in module %s line %u file %s",
  492.         defn_list->is_defn? "Defined":"Invoked",
  493.         type_name[t1],
  494.         defn_list->module->name,
  495.         defn_list->line_num,
  496.         defn_list->filename);
  497.     }
  498.    fprintf(list_fd,"\n\t%s type %s in module %s line %u file %s",
  499.         alist->is_defn? "Defined":"Invoked",
  500.         type_name[t2],
  501.         alist->module->name,
  502.         alist->line_num,
  503.         alist->filename);
  504.        }
  505.    }
  506.    alist = alist->next;
  507.  
  508.     }/* end while(alist != NULL) */
  509.          }/* end if(defn) */
  510.  
  511.   alist = glob_symtab[i].info.arglist;
  512.   while(alist != NULL){
  513.       if(alist != defn_list &&
  514.         /* Here we require true call, not use as actual arg.
  515.     Also, do not compare multiple defns against each other. */
  516.          (defn_list->is_defn || defn_list->is_call) &&
  517.          (alist->is_call) ){
  518.        arg_array_cmp(glob_symtab[i].name,defn_list,alist);
  519.    }
  520.    alist = alist->next;
  521.  
  522.   }/* end while(alist != NULL) */
  523.      }/* end else <alist != NULL> */
  524.  }/* end for (i=0; i<glob_symtab_top; i++) */
  525. }
  526.  
  527.  
  528. void
  529. check_comlists()        /* Scans global symbol table for common blocks */
  530. {
  531.  unsigned i, model_n;
  532.  ComListHeader *first_list, *model, *clist;
  533.  
  534.  if(comcheck_strictness == 0)
  535.   return;
  536.  
  537.  for (i=0; i<glob_symtab_top; i++){
  538.      if (storage_class_of(glob_symtab[i].type) != class_COMMON_BLOCK)
  539.   continue;
  540.      if((first_list=glob_symtab[i].info.comlist) == NULL){
  541.   fprintf(list_fd,"\nCommon block %s never defined",
  542.    glob_symtab[i].name);
  543.      }
  544.      else {
  545.         /* Find instance with most variables to use as model */
  546.   model=first_list;
  547.   model_n = first_list->numargs;
  548.   clist = model;
  549.   while( (clist=clist->next) != NULL ){
  550.       if(clist->numargs >= model_n) { /* if tie, use earlier */
  551.    model = clist;
  552.    model_n = clist->numargs;
  553.       }
  554.   }
  555.   clist = first_list;
  556.   while( clist != NULL ){
  557.       if(clist != model) {
  558.    if(comcheck_strictness <= 2)
  559.      com_cmp_lax(glob_symtab[i].name,model,clist);
  560.    else
  561.      com_cmp_strict(glob_symtab[i].name,model,clist);
  562.       }
  563.       clist = clist->next;
  564.   }
  565.      }
  566.  }
  567. } /* check_comlists */
  568.  
  569.  
  570.  
  571. com_cmp_lax(name,c1,c2)  /* Common-list check at levels 1 & 2 */
  572.      char *name;
  573.      ComListHeader *c1,*c2;
  574. {
  575.     int i1,i2,   /* count of common variables in each block */
  576.  done1,done2,  /* true when end of block reached */
  577.  type1,type2;  /* type of variable presently in scan */
  578.     unsigned long
  579.  len1,len2,  /* length of variable remaining */
  580.  word1,word2,  /* number of "words" scanned */
  581.  words1,words2,  /* number of "words" in block */
  582.  jump;   /* number of words to skip next in scan */
  583.  
  584.     int n1=c1->numargs,n2=c2->numargs; /* variable count for each block */
  585.     ComListElement *a1=c1->com_list_array, *a2=c2->com_list_array;
  586.  
  587.     /* Count words in each list */
  588.     words1=words2=0;
  589.     for(i1=0; i1<n1; i1++)
  590.       words1 += array_size(a1[i1].dimen_info);
  591.     for(i2=0; i2<n2; i2++)
  592.       words2 += array_size(a2[i2].dimen_info);
  593.  
  594.     if(comcheck_strictness >= 2 && words1 != words2) {
  595. fprintf(list_fd,"\nCommon block %s: varying length:", name);
  596. fprintf(list_fd,
  597.  "\n\tDeclared with %ld word%s in module %s line %u file %s",
  598.   words1, pluralize(words1),
  599.   c1->module->name,
  600.   c1->line_num,
  601.   c1->filename);
  602. fprintf(list_fd,
  603.  "\n\tDeclared with %ld word%s in module %s line %u file %s",
  604.   words2, pluralize(words2),
  605.   c2->module->name,
  606.   c2->line_num,
  607.   c2->filename);
  608.     }
  609.  
  610.     /* Now check type matches */
  611.     done1=done2=FALSE;
  612.     i1=i2=0;
  613.     len1=len2=0;
  614.     word1=word2=1;
  615.     for(;;) {
  616.  if(len1 == 0) {  /* move to next variable in list 1 */
  617.      if(i1 == n1) {
  618.   done1 = TRUE;
  619.      }
  620.      else {
  621.   type1 = a1[i1].type;
  622.   len1 = array_size(a1[i1].dimen_info);
  623.   ++i1;
  624.      }
  625.  }
  626.  if(len2 == 0) {  /* move to next variable in list 2 */
  627.      if(i2 == n2) {
  628.   done2 = TRUE;
  629.      }
  630.      else {
  631.   type2 = a2[i2].type;
  632.   len2 = array_size(a2[i2].dimen_info);
  633.   ++i2;
  634.      }
  635.  }
  636.  
  637.  if(done1 || done2){ /* either list exhausted? */
  638.      break;  /* then stop checking */
  639.  }
  640.  
  641.  if(type1 != type2) { /* type clash? */
  642. fprintf(list_fd,"\nCommon block %s: data type mismatch",
  643.   name);
  644. fprintf(list_fd,
  645.  "\n\tWord %ld is type %s in module %s line %u file %s",
  646.    word1,
  647.    type_name[type1],
  648.    c1->module->name,
  649.    c1->line_num,
  650.    c1->filename);
  651. fprintf(list_fd,
  652.  "\n\tWord %ld is type %s in module %s line %u file %s",
  653.    word2,
  654.    type_name[type2],
  655.    c2->module->name,
  656.    c2->line_num,
  657.    c2->filename);
  658.      break;  /* stop checking at first mismatch */
  659.  }
  660.    /* Advance along list by largest possible
  661.       step that does not cross a variable boundary
  662.     */
  663.  jump = len1 < len2? len1: len2; /* min(len1,len2) */
  664.  len1 -= jump;
  665.  len2 -= jump;
  666.  word1 += jump;
  667.  word2 += jump;
  668.     }/* end for(;;) */
  669. }
  670.  
  671. PRIVATE void
  672. com_cmp_strict(name,c1,c2) /* Common-list check at levels 1 & 2 */
  673.  char *name;
  674.  ComListHeader *c1, *c2;
  675. {
  676.  int i,
  677.      typerr = 0,
  678.      dimerr = 0;
  679.  short n,
  680.        n1 = c1->numargs,
  681.        n2 = c2->numargs;
  682.  ComListElement *a1 = c1->com_list_array,
  683.          *a2 = c2->com_list_array;
  684.  
  685.  n = (n1 > n2) ? n2: n1;
  686.  for (i=0; i<n; i++){
  687.      if(a1[i].type != a2[i].type){
  688.   typerr = 1;
  689.   break;
  690.      }
  691.  }
  692.  for (i=0; i<n; i++){
  693.      if(a1[i].dimen_info != a2[i].dimen_info){
  694.   dimerr = 1;
  695.   break;
  696.      }
  697.  }
  698.  if(n1 != n2){
  699. fprintf(list_fd,"\nCommon block %s: varying length:", name);
  700. fprintf(list_fd,
  701.  "\n\tDeclared with %d variable%s in module %s line %u file %s",
  702.           n1,pluralize(n1),
  703.       c1->module->name,
  704.       c1->line_num,
  705.       c1->filename);
  706. fprintf(list_fd,
  707.  "\n\tDeclared with %d variable%s in module %s line %u file %s",
  708.       n2,pluralize(n2),
  709.       c2->module->name,
  710.       c2->line_num,
  711.       c2->filename);
  712.         }
  713.  if(typerr){
  714.      typerr = 0;  /* start count over again */
  715.     fprintf(list_fd,"\nCommon block %s: data type mismatch",
  716.       name);
  717.      for (i=0; i<n; i++) {
  718.   if(a1[i].type != a2[i].type){
  719.       int t1 = datatype_of(a1[i].type),
  720.    t2 = datatype_of(a2[i].type);
  721.  
  722.     /* stop after limit: probably a cascade */
  723.    if(++typerr > CMP_ERR_LIMIT) {
  724.     fprintf(list_fd,"\n etc...");
  725.     break;
  726.    }
  727.  
  728. fprintf(list_fd, "\n  at position %d:", i+1);
  729. fprintf(list_fd,"\n\tVariable declared type %s in module %s line %u file %s",
  730.        type_name[t1],
  731.        c1->module->name,
  732.        c1->line_num,
  733.        c1->filename);
  734. fprintf(list_fd,"\n\tVariable declared type %s in module %s line %u file %s",
  735.        type_name[t2],
  736.        c2->module->name,
  737.        c2->line_num,
  738.        c2->filename);
  739.  
  740.   }
  741.      }
  742.  }
  743.  if(dimerr){
  744.      dimerr = 0;  /* start count over again */
  745.     fprintf(list_fd,"\nCommon block %s: array dimen/size mismatch",
  746.   name);
  747.      for (i=0; i<n; i++){
  748.   unsigned long d1, d2, s1, s2;
  749.  
  750.   if((d1=array_dims(a1[i].dimen_info)) !=
  751.    (d2=array_dims(a2[i].dimen_info))){
  752.  
  753.     /* stop after limit: probably a cascade */
  754.    if(++dimerr > CMP_ERR_LIMIT) {
  755.     fprintf(list_fd,"\n etc...");
  756.     break;
  757.    }
  758. fprintf(list_fd, "\nat position %d:", i+1);
  759. fprintf(list_fd,
  760.  "\n\tDeclared with %ld dimension%s in module %s line %u file %s",
  761.        d1,pluralize(d1),
  762.        c1->module->name,
  763.        c1->line_num,
  764.        c1->filename);
  765. fprintf(list_fd,
  766.  "\n\tDeclared with %ld dimension%s in module %s line %u file %s",
  767.        d2,pluralize(d2),
  768.        c2->module->name,
  769.        c2->line_num,
  770.        c2->filename);
  771.   }
  772.  
  773.   if((s1=array_size(a1[i].dimen_info)) !=
  774.    (s2=array_size(a2[i].dimen_info))){
  775.  
  776.     /* stop after limit: probably a cascade */
  777.    if(++dimerr > CMP_ERR_LIMIT) {
  778.     fprintf(list_fd,"\n etc...");
  779.     break;
  780.    }
  781.     fprintf(list_fd, "\nat position %d:", i+1);
  782.     fprintf(list_fd,
  783.  "\n\tDeclared with size %ld in module %s line %u file %s",
  784.        s1,
  785.        c1->module->name,
  786.        c1->line_num,
  787.        c1->filename);
  788.     fprintf(list_fd,
  789.  "\n\tDeclared with size %ld in module %s line %u file %s",
  790.        s2,
  791.        c2->module->name,
  792.        c2->line_num,
  793.        c2->filename);
  794.   }
  795.      }
  796.  }
  797. }/*com_cmp_strict*/
  798.  
  799. PRIVATE void
  800. sort_symbols(sp,n)      /* sorts a given list */
  801.  symtab *sp[];
  802.  unsigned n;
  803. {
  804.  int i,j,swaps;
  805.  for(i=0;i<n;i++) {
  806.      swaps = 0;
  807.      for(j=n-1;j>=i+1;j--) {
  808.   if((strcmp(sp[j-1]->name, sp[j]->name)) > 0) {
  809.      swap_symptrs(&sp[j-1], &sp[j]);
  810.      swaps ++;
  811.   }
  812.      }
  813.      if(swaps == 0) break;
  814.  }
  815. }
  816.  
  817.  
  818. PRIVATE void   /* swaps two pointers */
  819. swap_symptrs(x_ptr,y_ptr)
  820.  symtab **x_ptr,**y_ptr;
  821. {
  822.  symtab *temp = *x_ptr;
  823.  *x_ptr = *y_ptr;
  824.  *y_ptr = temp;
  825. }
  826.  
  827.  
  828. void
  829. print_loc_symbols(curmodhash)
  830.      int curmodhash;  /* hash entry of current module */
  831. {
  832.     symtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
  833.     int mod_type,  /* datatype of this module */
  834.  this_is_a_function; /* flag for treating funcs specially */
  835.     symtab *module;   /* entry of current module in symtab */
  836.     char *mod_name;  /* module name */
  837.     unsigned
  838.  com_vars_modified=0, /* count of common variables which are set */
  839.  args_modified=0, /* count of arguments which are set */
  840.  imps=0,   /* count of implicitly declared identifiers */
  841.  numentries;  /* count of entry points of module */
  842.  
  843.  
  844.  
  845.    /* Keep track of symbol table and string usage */
  846.     if(loc_symtab_top > max_loc_symtab) {
  847.  max_loc_symtab = loc_symtab_top;
  848.     }
  849.     if(loc_str_top > max_loc_strings) {
  850.  max_loc_strings = loc_str_top;
  851.     }
  852.     if(token_space_top > max_token_space) {
  853.         max_token_space = token_space_top;
  854.     }
  855.    /* Global symbols only increase in number */
  856.     max_glob_symtab = glob_symtab_top;
  857.     max_glob_strings = STRSPACESZ - glob_str_bot;
  858.  
  859.  
  860.  
  861.       /* Set up name & type, and see what kind of module it is */
  862.  
  863.        module = hashtab[curmodhash].loc_symtab;
  864.  
  865.        mod_name = module->name;
  866.        mod_type = get_type(module);
  867.  
  868.        if(  mod_type != type_PROGRAM
  869.   && mod_type != type_SUBROUTINE
  870.   && mod_type != type_COMMON_BLOCK
  871.   && mod_type != type_BLOCK_DATA )
  872.    this_is_a_function = TRUE;
  873.        else
  874.    this_is_a_function = FALSE;
  875.  
  876.       /* Print name & type of the module */
  877.     if(do_symtab) {
  878.       unsigned i;
  879.       for(i=0,numentries=0;i<loc_symtab_top;i++) {
  880.  if(loc_symtab[i].entry_point)
  881.    sym_list[numentries++] = &loc_symtab[i];
  882.       }
  883.  
  884.     if(numentries > 1) {
  885.        sort_symbols(sym_list,numentries);
  886.     }
  887.  
  888.  
  889.    fprintf(list_fd,"\n\nModule %s:",mod_name);
  890.    if( this_is_a_function ) fprintf(list_fd," func:");
  891.    fprintf(list_fd," %4s",type_name[mod_type]);
  892.    /* Print a * next to non-declared function name */
  893.    if(datatype_of(module->type) == type_UNDECL ) {
  894.    fprintf(list_fd,"*");
  895.    imps++;
  896.    }
  897.    fprintf(list_fd,"\n");
  898.  
  899.  
  900.     /* Print Entry Points (skip if only one,
  901.        since it is same as module name) */
  902.       if(do_symtab && numentries > 1) {
  903.        fprintf(list_fd,"\nEntry Points\n");
  904.        (void) print_symbols(list_fd,sym_list,numentries,FALSE);
  905.       }
  906.  
  907.    /* End of printing module name and entry points */
  908.     }/*if(do_symtab)*/
  909.  
  910.  
  911.  
  912.     /* Print the externals */
  913.  
  914.     if(do_symtab) {
  915.         unsigned i,n;
  916.  for(i=0,n=0;i<loc_symtab_top;i++) {
  917.      if(storage_class_of(loc_symtab[i].type) == class_SUBPROGRAM) {
  918.           sym_list[n++] = &loc_symtab[i];
  919.      }
  920.  }
  921.  if(n != 0) {
  922.        sort_symbols(sym_list,n);
  923.  
  924.  
  925.        fprintf(list_fd,"\nExternal subprograms referenced:\n");
  926.        imps += print_symbols(list_fd,sym_list,n,TRUE);
  927.  }
  928.  
  929.       }/*if(do_symtab)*/
  930.  
  931.  
  932.     /* Print list of statement functions */
  933.     if(do_symtab) {
  934.            unsigned i,n;
  935.  
  936.     for(i=0,n=0;i<loc_symtab_top;i++) {
  937.         if(storage_class_of(loc_symtab[i].type) == class_STMT_FUNCTION){
  938.           sym_list[n++] = &loc_symtab[i];
  939.         }
  940.     }
  941.     if(n != 0) {
  942.        sort_symbols(sym_list,n);
  943.        fprintf(list_fd,"\nStatement functions defined:\n");
  944.        imps += print_symbols(list_fd,sym_list,n,TRUE);
  945.      }
  946.     }/*if(do_symtab)*/
  947.  
  948.  
  949.     /* Print the common blocks */
  950.     if(do_symtab || port_check) {
  951.            unsigned i,numblocks;
  952.  
  953.     for(i=0,numblocks=0;i<loc_symtab_top;i++) {
  954.        if(storage_class_of(loc_symtab[i].type) == class_COMMON_BLOCK) {
  955.           sym_list[numblocks++] = &loc_symtab[i];
  956.        }
  957.     }
  958.  
  959.     if(numblocks != 0) {
  960.        sort_symbols(sym_list,numblocks);
  961.        if(do_symtab) {
  962.     fprintf(list_fd,"\nCommon blocks referenced:\n");
  963.     (void) print_symbols(list_fd,sym_list,numblocks,FALSE);
  964.        }
  965.        if(port_check) {
  966.       check_mixed_common(list_fd,sym_list,numblocks);
  967.        }
  968.     }
  969.      }/*if(do_symtab||port_check)*/
  970.  
  971.  
  972.  
  973.     /* Process the variables */
  974.  
  975.     if(do_symtab || usage_check) {
  976.         unsigned i,n;
  977.  
  978.  for(i=0,n=0;i<loc_symtab_top;i++) {
  979.         if(storage_class_of(loc_symtab[i].type) == class_VAR
  980.         && (!loc_symtab[i].entry_point || this_is_a_function)) {
  981.     sym_list[n++] = &loc_symtab[i];
  982.     if(loc_symtab[i].argument && loc_symtab[i].set_flag)
  983.      ++args_modified;
  984.     if(loc_symtab[i].common_var && loc_symtab[i].set_flag)
  985.      ++com_vars_modified;
  986.         }
  987.  }
  988.  
  989.  if(n != 0) {
  990.     sort_symbols(sym_list,n);
  991.  
  992.    /* Print the variables */
  993.  
  994.     if(do_symtab) {
  995.        fprintf(list_fd,"\nVariables:\n ");
  996.        imps += print_variables(sym_list,n);
  997.     }
  998.         }
  999.    /* Explain the asterisk on implicitly defined
  1000.       identifiers.  Note that this message will
  1001.       be given also if functions implicitly defined */
  1002.  if(do_symtab && imps != 0) {
  1003.       fprintf(list_fd,"\n* Variable not declared.");
  1004.       fprintf(list_fd," Type has been implicitly defined.\n");
  1005.  }
  1006.  
  1007.  if(usage_check) {
  1008.    if(do_symtab || do_list)
  1009.      fprintf(list_fd,"\n");
  1010.    check_flags(sym_list,n,0,0,0,
  1011.         "declared but never referenced",mod_name);
  1012.    check_flags(sym_list,n,0,1,0,
  1013.         "set but never used",mod_name);
  1014.    check_flags(sym_list,n,1,0,1,
  1015.         "used before set",mod_name);
  1016.    check_flags(sym_list,n,1,1,1,
  1017.         "may be used before set",mod_name);
  1018.  
  1019.     /* Warn if "impure" function */
  1020.    if(this_is_a_function && novice_level <= 4) {
  1021.      if(args_modified != 0)
  1022.        fprintf(list_fd,"\nFunction %s modifies some of its arguments",
  1023.      mod_name);
  1024.      if(com_vars_modified != 0)
  1025.        fprintf(list_fd,"\nFunction %s modifies some common variables",
  1026.      mod_name);
  1027.    }
  1028.  }/*end if(usage_check)*/
  1029.  
  1030.  if(do_symtab || do_list)
  1031.    fprintf(list_fd,"\n");
  1032.  
  1033.     }/* end if(do_symtab || usage_check) */
  1034.  
  1035.    /* List all undeclared vars & functions */
  1036.     if(decls_required || implicit_none) {
  1037.         unsigned i,n;
  1038.  
  1039.  for(i=0,n=0;i<loc_symtab_top;i++) {
  1040.      if(datatype_of(loc_symtab[i].type) == type_UNDECL
  1041.   && ! loc_symtab[i].intrinsic /* omit intrinsics */
  1042.     /* omit subroutines called */
  1043.   && (!loc_symtab[i].external || loc_symtab[i].invoked_as_func)
  1044.         ) {
  1045.   sym_list[n++] = &loc_symtab[i];
  1046.      }
  1047.  }
  1048.  if(n != 0) {
  1049.      sort_symbols(sym_list,n);
  1050.      fprintf(list_fd,"\nIdentifiers of undeclared type in module %s:",
  1051.       mod_name);
  1052.      (void) print_symbols(list_fd,sym_list,n,FALSE);
  1053.  }
  1054.     }/*if(decls_required || implicit_none)*/
  1055.  
  1056.   /* issue portability warning for identifiers
  1057.      longer than 6 characters
  1058.   */
  1059.     if(f77_standard) {
  1060.         unsigned i,n;
  1061.  for(i=0,n=0;i<loc_symtab_top;i++) {
  1062.         if(strlen(loc_symtab[i].name) > 6)
  1063.     sym_list[n++] = &loc_symtab[i];
  1064.  }
  1065.  
  1066.  if(n != 0) {
  1067.  
  1068.     sort_symbols(sym_list,n);
  1069.  
  1070.     ++warning_count;
  1071.  
  1072.     fprintf(list_fd,
  1073.     "\nNames longer than 6 chars in module %s (nonstandard):",
  1074.    mod_name);
  1075.     (void) print_symbols(list_fd,sym_list,n,FALSE);
  1076.  }
  1077.     }
  1078.  
  1079.  /* If -f77 flag given, list names with underscore or dollarsign */
  1080.  
  1081. #if ALLOW_UNDERSCORES || ALLOW_DOLLARSIGNS
  1082.     if(f77_standard) {
  1083.         unsigned i,n;
  1084.  for(i=0,n=0;i<loc_symtab_top;i++) {
  1085.    /* Find all names with nonstd chars, but
  1086.       exclude internal names like %MAIN */
  1087.         if(has_nonalnum(loc_symtab[i].name) &&
  1088.     loc_symtab[i].name[0] != '%')
  1089.     sym_list[n++] = &loc_symtab[i];
  1090.  }
  1091.  
  1092.  if(n != 0) {
  1093.  
  1094.     sort_symbols(sym_list,n);
  1095.  
  1096.     ++warning_count;
  1097.  
  1098.     fprintf(list_fd,
  1099.     "\nNames containing nonstandard characters in module %s:",
  1100.    mod_name);
  1101.     (void) print_symbols(list_fd,sym_list,n,FALSE);
  1102.  }
  1103.     }/*if(f77_standard)*/
  1104. #endif
  1105.  
  1106.    /* Print out clashes in first six chars of name */
  1107.     if(sixclash) {
  1108.   unsigned n;
  1109.   n = find_sixclashes(sym_list);
  1110.   if(n != 0) {
  1111.      sort_symbols(sym_list,n);
  1112.      fprintf(list_fd,
  1113.     "\nIdentifiers which are not unique in first six chars in module %s:"
  1114.   ,mod_name);
  1115.      (void) print_symbols(list_fd,sym_list,n,FALSE);
  1116.   }/* end if(n != 0) */
  1117.     }/* end if(sixclash) */
  1118.  
  1119.   /* For beginners, give a warning if any arguments are
  1120.      external functions.  May be undeclared arrays. */
  1121.  
  1122.     if(novice_level <= 2) {
  1123.  unsigned i,n;
  1124.  for(i=0,n=0;i<loc_symtab_top;i++) {
  1125.         if(loc_symtab[i].argument && loc_symtab[i].external
  1126.    && datatype_of(loc_symtab[i].type) != type_SUBROUTINE
  1127.    && !loc_symtab[i].declared_external)
  1128.     sym_list[n++] = &loc_symtab[i];
  1129.  }
  1130.  if(n != 0) {
  1131.     sort_symbols(sym_list,n);
  1132.     ++warning_count;
  1133.     fprintf(list_fd,
  1134.  "\nWarning in module %s: possibly undeclared array%s:",
  1135.   mod_name,pluralize(n));
  1136.     (void) print_symbols(list_fd,sym_list,n,FALSE);
  1137.  }
  1138.     }/*if(novice_level <= 2)*/
  1139.   /* If portability flag was given, check equivalence
  1140.      groups for mixed type. */
  1141.     if(port_check) {
  1142.         unsigned i,j,n;
  1143.  int caption_given=FALSE;
  1144.  unsigned imps=0;
  1145.  symtab *equiv;
  1146.  
  1147.   /* scan thru table for equivalenced variables */
  1148.  for(i=0;i<loc_symtab_top;i++) {
  1149.      if(storage_class_of(loc_symtab[i].type) == class_VAR
  1150.         && loc_symtab[i].equiv_link != (equiv= &loc_symtab[i]) ){
  1151.   n=0;
  1152.   do {
  1153.       if(equiv < &loc_symtab[i]) { /* skip groups done before */
  1154.    n=0;
  1155.    break;
  1156.       }
  1157.       sym_list[n++] = equiv;
  1158.       equiv = equiv->equiv_link;
  1159.   } while(equiv != &loc_symtab[i]); /* complete the circle */
  1160.     /* Check for mixed types */
  1161.   if(n != 0) {
  1162.       int mixed_type = FALSE;
  1163.       for(j=1; j<n; j++) {
  1164.    if(get_type(sym_list[j]) != get_type(sym_list[j-1])) {
  1165.        mixed_type = TRUE;
  1166.        break;
  1167.    }
  1168.       }
  1169.  
  1170.       if(mixed_type) {
  1171.    sort_symbols(sym_list,n);
  1172.    if(caption_given)/* give short or long caption */
  1173.        fprintf(list_fd," and");
  1174.    else {
  1175.        fprintf(list_fd,
  1176.        "\nMixed types equivalenced in module %s",
  1177.         mod_name);
  1178.        fprintf(list_fd,
  1179.         " (not portable):");
  1180.        caption_given = TRUE;
  1181.    }
  1182.    imps += print_symbols(list_fd,sym_list,n,TRUE);
  1183.       }
  1184.   }
  1185.      }
  1186.  }
  1187.  if(imps != 0) {
  1188.       fprintf(list_fd,"\n* Variable not declared.");
  1189.       fprintf(list_fd," Type has been implicitly defined.\n");
  1190.  }
  1191.  
  1192.     }/*if(port_check)*/
  1193.  
  1194. }/* print_loc_symbols */
  1195.  
  1196. PRIVATE int
  1197. has_nonalnum(s) /* Returns TRUE if s contains a non-alphanumeric character */
  1198.    char *s;
  1199. {
  1200.    while( *s != '\0' )
  1201.      if( ! isalnum( (int)(*s++) ) )
  1202.        return TRUE;
  1203.    return FALSE;
  1204. }
  1205.  
  1206.      /* This routine prints symbol names neatly.  If do_types is true
  1207.  also prints types, with * next to implicitly
  1208.  typed identifiers, and returns count thereof. */
  1209.  
  1210. PRIVATE unsigned
  1211. print_symbols(fd,sym_list,n,do_types)
  1212.      FILE *fd;
  1213.      symtab *sym_list[];
  1214.      unsigned n;
  1215.      int do_types;
  1216. {
  1217.      unsigned i,col=0,len,implicits=0;
  1218.  
  1219.      fprintf(fd,"\n");
  1220.  
  1221.      for(i=0;i<n;i++) {
  1222.    len = strlen(sym_list[i]->name);
  1223.    col += len = (len <= 10? 10: len) + 9;
  1224.    if(col > 78) {
  1225.      fprintf(fd,"\n");
  1226.      col = len;
  1227.    }
  1228.    fprintf(fd,"%10s",sym_list[i]->name);
  1229.    if( do_types ) {
  1230.      if(sym_list[i]->intrinsic)
  1231.        fprintf(fd,": intrns ");
  1232.      else
  1233.        fprintf(fd,": %4s%1s  ",
  1234.       type_name[get_type(sym_list[i])],
  1235.       (datatype_of(sym_list[i]->type) == type_UNDECL)?
  1236.         (implicits++,"*" ) : ""
  1237.       );
  1238.    }
  1239.    else
  1240.      fprintf(fd,"%9s","");
  1241.      }
  1242.  
  1243.      fprintf(fd,"\n");
  1244.  
  1245.      return implicits;
  1246.  
  1247. }/*print_symbols*/
  1248.  
  1249.  
  1250.  
  1251.  /* This routine prints the variables nicely, and returns
  1252.      count of number implicitly defined.
  1253.   */
  1254. PRIVATE unsigned
  1255. print_variables(sym_list,n)
  1256.      symtab *sym_list[];
  1257.      unsigned n;
  1258. {
  1259.      unsigned i,implicits=0;
  1260.  
  1261.      fprintf(list_fd,"\n ");
  1262.  
  1263.      for(i=0; i<4; i++) {
  1264.    fprintf(list_fd,"%5sName Type Dims","");
  1265.         /* 12345678901234567890 template for above*/
  1266.      }
  1267.      for(i=0; i<n; i++) {
  1268.    if(i % 4 == 0)
  1269.       fprintf(list_fd,"\n");
  1270.    else
  1271.       fprintf(list_fd," ");
  1272.  
  1273.    fprintf(list_fd,"%10s",sym_list[i]->name);
  1274.    /* Print a * next to non-declared variables */
  1275.    fprintf(list_fd," %4s%1s",
  1276.        type_name[get_type(sym_list[i])],
  1277.        (datatype_of(sym_list[i]->type) == type_UNDECL )?
  1278.            (implicits++,"*") : ""
  1279.     );
  1280.  
  1281.    /* print no. of dimensions next to var name */
  1282.    if(sym_list[i]->array_var) {
  1283.   fprintf(list_fd," %ld",
  1284.           array_dims(sym_list[i]->info.array_dim));
  1285.    }
  1286.    else {
  1287.     fprintf(list_fd,"%2s","");
  1288.    }
  1289.     }
  1290.  
  1291.     fprintf(list_fd,"\n");
  1292.  
  1293.     return implicits;
  1294.  
  1295. }/*print_variables*/
  1296.  
  1297.  
  1298.  /* Search thru local symbol table for clashes where identifiers
  1299.     are not unique in 1st six characters. Return value =
  1300.     number of clashes found, with pointers to symbol table
  1301.     entries of clashers in array list. */
  1302. PRIVATE unsigned
  1303. find_sixclashes(list)
  1304.  symtab *list[];
  1305. {
  1306.  unsigned i,h, clashes=0;
  1307.  int class;
  1308.  unsigned long hnum;
  1309.  
  1310.  for(i=0; i<loc_symtab_top; i++) { /* Scan thru symbol table */
  1311.      class = storage_class_of(loc_symtab[i].type);
  1312.      hnum = hash( loc_symtab[i].name );
  1313.     /* First look for a clash of any kind.
  1314.        (N.B. this loop will never quit if hash
  1315.        table is full, but let's not worry) */
  1316.      while( (h=hnum % HASHSZ), hashtab[h].name != (char *)NULL) {
  1317.   /* Now see if the clashing name is used locally and still
  1318.      clashes at 6 chars.  Treat common blocks separately. */
  1319.  
  1320.       if((class == class_COMMON_BLOCK &&
  1321.            (
  1322.      hashtab[h].com_loc_symtab != NULL
  1323.      && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
  1324.      && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
  1325.     )
  1326.   )  ||
  1327.    (class != class_COMMON_BLOCK &&
  1328.     (
  1329.      hashtab[h].loc_symtab != NULL
  1330.      && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
  1331.      && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
  1332.     )
  1333.    )
  1334.         ) {
  1335.     /* If so, then i'th symbol is a clash */
  1336.  
  1337.    list[clashes++] = &loc_symtab[i];
  1338.    break;
  1339.   }
  1340.   else {
  1341.       hnum = rehash(hnum);
  1342.   }
  1343.      }
  1344.  }
  1345.  return clashes;
  1346. }
  1347.  
  1348.  
  1349. PRIVATE void
  1350. print_arg_array(arglist)        /* prints type and flag info for arguments */
  1351.  ArgListHeader *arglist;
  1352. {
  1353.  int i, count;
  1354.  ArgListElement *a;
  1355.  
  1356.  count = arglist->numargs;
  1357.  if(arglist->external_decl || arglist->actual_arg)
  1358.    count = 0;
  1359.  a = arglist->arg_array;
  1360.  fprintf(list_fd,"\nArg array ref in module %s file %s line %u:",
  1361.   arglist->module->name, arglist->filename, arglist->line_num);
  1362.  fprintf(list_fd,"\n\tdef%d call%d ext%d arg%d",
  1363.   arglist->is_defn,
  1364.   arglist->is_call,
  1365.   arglist->external_decl,
  1366.   arglist->actual_arg);
  1367.  if(count == 0)
  1368.   fprintf(list_fd,"\n(Empty)");
  1369.  else {
  1370.      for (i=0; i<count; i++) {
  1371.   fprintf(list_fd,
  1372.    "\n\t%d %s: lv%d st%d as%d ub%d ar%d ae%d ex%d",
  1373.    i+1,
  1374.    type_name[datatype_of(a[i].type)],
  1375.     a[i].is_lvalue,
  1376.     a[i].set_flag,
  1377.     a[i].assigned_flag,
  1378.     a[i].used_before_set,
  1379.     a[i].array_var,
  1380.     a[i].array_element,
  1381.     a[i].declared_external);
  1382.   if(a[i].array_var)
  1383.       fprintf(list_fd,"(%ld,%ld)",
  1384.    array_dims(a[i].info.array_dim),
  1385.    array_size(a[i].info.array_dim) );
  1386.   fprintf(list_fd,", ");
  1387.      }
  1388.  }
  1389. }/* print_arg_array */
  1390.  
  1391.  
  1392.         /* prints type and dimen info for common vars */
  1393. PRIVATE void
  1394. print_com_array(cmlist)
  1395.  ComListHeader *cmlist;
  1396. {
  1397.  int i, count;
  1398.  ComListElement *c;
  1399.  
  1400.  fprintf(list_fd,"\n\t");
  1401.  count = cmlist->numargs;
  1402.  c = cmlist->com_list_array;
  1403.  if(count == 0)
  1404.   fprintf(list_fd,"(Empty)");
  1405.  else {
  1406.      for (i=0; i<count; i++){
  1407.   fprintf(list_fd,"%s",type_name[datatype_of(c[i].type)]);
  1408.   if(c[i].dimen_info)
  1409.       fprintf(list_fd,":%ldD(%ld)",array_dims(c[i].dimen_info),
  1410.         array_size(c[i].dimen_info));
  1411.   fprintf(list_fd,", ");
  1412.      }
  1413.  }
  1414. }/* print_com_array */
  1415.  
  1416. #if 0    /* print_tokenlist currently unused */
  1417. PRIVATE void
  1418. print_tokenlist(toklist)        /* prints list of token names or types */
  1419.  TokenListHeader *toklist;
  1420. {
  1421.  int numargs=0;
  1422.  Token *t;
  1423.  fprintf(list_fd,"\n");
  1424.  if (toklist == NULL){
  1425.      fprintf(list_fd,"\t(None)");
  1426.  }
  1427.  else {
  1428.      t = toklist->tokenlist;
  1429.      while(t != NULL){
  1430.   ++numargs;
  1431.   fprintf(list_fd," ");
  1432.   if ( is_true(ID_EXPR,t->subclass) )
  1433.       fprintf(list_fd,"%s ",token_name(*t));
  1434.   else
  1435.       fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
  1436.   t = t->next_token;
  1437.      }
  1438.      if(numargs == 0)
  1439.       fprintf(list_fd,"\t(Empty)");
  1440.  }
  1441. }/* print_tokenlist */
  1442. #endif
  1443.  
  1444. void
  1445. debug_symtabs()  /* Debugging output: hashtable and symbol tables */
  1446. {
  1447.   if(debug_loc_symtab) {
  1448.     fprintf(list_fd,"\n Debugging of local symbol table disabled");
  1449.     return;
  1450.   }
  1451.  
  1452.     if(debug_hashtab) {
  1453.         int i;
  1454.  fprintf(list_fd,"\n\nContents of hashtable\n");
  1455.  for(i=0; i<HASHSZ; i++) {
  1456.      if(hashtab[i].name != NULL) {
  1457.        fprintf(list_fd,"\n%4d %s",i,hashtab[i].name);
  1458.        if(hashtab[i].loc_symtab != NULL)
  1459.   fprintf(list_fd," loc %d",hashtab[i].loc_symtab-loc_symtab);
  1460.        if(hashtab[i].glob_symtab != NULL)
  1461.   fprintf(list_fd,
  1462.    " glob %d",hashtab[i].glob_symtab-glob_symtab);
  1463.        if(hashtab[i].com_loc_symtab != NULL)
  1464.   fprintf(list_fd,
  1465.    " Cloc %d",hashtab[i].com_loc_symtab-loc_symtab);
  1466.        if(hashtab[i].com_glob_symtab != NULL)
  1467.   fprintf(list_fd,
  1468.    " Cglob %d",hashtab[i].com_glob_symtab-glob_symtab);
  1469.      }
  1470.  }
  1471.     }
  1472.  
  1473.     if(debug_glob_symtab) {
  1474.         int i;
  1475.  fprintf(list_fd,"\n\nContents of global symbol table");
  1476.  fprintf(list_fd,
  1477. "\n i name type u s asg ubs cumd lbmd ary com ent par arg ext int invf dex");
  1478.  for(i=0; i<glob_symtab_top; i++) {
  1479.      fprintf(list_fd,
  1480.   "\n%4d %s 0x%x %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d",
  1481.   i,
  1482.   glob_symtab[i].name,
  1483.   glob_symtab[i].type,
  1484.   glob_symtab[i].used_flag,
  1485.   glob_symtab[i].set_flag,
  1486.   glob_symtab[i].assigned_flag,
  1487.   glob_symtab[i].used_before_set,
  1488.   glob_symtab[i].is_current_module,
  1489.   glob_symtab[i].library_module,
  1490.   glob_symtab[i].array_var,
  1491.   glob_symtab[i].common_var,
  1492.   glob_symtab[i].entry_point,
  1493.   glob_symtab[i].parameter,
  1494.   glob_symtab[i].argument,
  1495.   glob_symtab[i].external,
  1496.   glob_symtab[i].intrinsic,
  1497.   glob_symtab[i].invoked_as_func,
  1498.   glob_symtab[i].declared_external
  1499.       );
  1500.      switch(storage_class_of(glob_symtab[i].type)){
  1501.   case class_COMMON_BLOCK:{
  1502.       ComListHeader *clist;
  1503.       clist=glob_symtab[i].info.comlist;
  1504.       while(clist != NULL){
  1505.    print_com_array(clist);
  1506.    clist = clist->next;
  1507.       }
  1508.       break;
  1509.   }
  1510.   case class_SUBPROGRAM:{
  1511.       ArgListHeader *alist;
  1512.       alist=glob_symtab[i].info.arglist;
  1513.       while(alist != NULL){
  1514.    print_arg_array(alist);
  1515.    alist = alist->next;
  1516.       }
  1517.       break;
  1518.   }
  1519.      }
  1520.  }
  1521.     }
  1522.  
  1523. }/* debug_symtabs*/
  1524.  
  1525.  
  1526. PRIVATE void
  1527. check_mixed_common(fd,sym_list,n)
  1528.      FILE *fd;
  1529.      symtab *sym_list[];
  1530.      int n;
  1531. {
  1532.     int i;
  1533.     for(i=0; i<n; i++) {
  1534.  ComListHeader *chead = sym_list[i]->info.comlist;
  1535.  ComListElement *clist;
  1536.  int j,nvars;
  1537.  int has_char=FALSE,has_nonchar=FALSE;
  1538.  int size, next_size;
  1539.  
  1540.  if(chead == NULL)
  1541.    continue;
  1542.  clist=chead->com_list_array;
  1543.  nvars = chead->numargs;
  1544.  
  1545.  if(nvars > 0)
  1546.    size = type_size[datatype_of(clist[0].type)];
  1547.  
  1548.  for(j=0; j<nvars; j++) {
  1549.  
  1550.     /* Check conformity to ANSI rule: no mixing char with other types */
  1551.  
  1552.    if(datatype_of(clist[j].type) == type_STRING)
  1553.      has_char = TRUE;
  1554.    else
  1555.      has_nonchar = TRUE;
  1556.    if(has_char && has_nonchar) {
  1557.      fprintf(fd,
  1558.       "\nCommon block %s line %u module %s has mixed",
  1559.       sym_list[i]->name,
  1560.       chead->line_num,
  1561.       chead->module->name);
  1562.      fprintf(fd,"\n  character and non-character variables");
  1563.      fprintf(fd," (may not be portable)");
  1564.      break;
  1565.    }
  1566.  
  1567.  /* Check that variables are in descending order of type size */
  1568.  
  1569.    if( (next_size = type_size[datatype_of(clist[j].type)]) > size ) {
  1570.      fprintf(fd,
  1571.       "\nCommon block %s line %u module %s has long data type",
  1572.       sym_list[i]->name,
  1573.       chead->line_num,
  1574.       chead->module->name);
  1575.      fprintf(fd,
  1576.       "\n  following short data type (may not be portable)");
  1577.      break;
  1578.    }
  1579.    size = next_size;
  1580.  }
  1581.     }
  1582. }
  1583.  
  1584.  
  1585. PRIVATE
  1586. void
  1587. check_flags(list,n,used,set,ubs,msg,mod_name)
  1588.  symtab *list[];
  1589.  int n;
  1590.  unsigned used,set,ubs;
  1591.  char *msg,*mod_name;
  1592. {
  1593.  int matches=0,col=0,unused_args=0,i,len;
  1594.  unsigned pattern = flag_combo(used,set,ubs);
  1595.  
  1596.  for(i=0;i<n;i++) {
  1597.      if( list[i]->common_var ) /* common vars are immune */
  1598.         continue;
  1599.     /* for args, do only 'never used' */
  1600.      if( list[i]->argument && pattern != flag_combo(0,0,0) )
  1601.         continue;
  1602.  
  1603. #ifdef ALLOW_INCLUDE
  1604.     /* for parameters defined in include files,
  1605.        skip 'set but never used' */
  1606.      if( list[i]->parameter && list[i]->defined_in_include
  1607.         && pattern == flag_combo(0,1,0) )
  1608.          continue;
  1609. #endif
  1610.    /*  function return val: ignore 'set but never used' */
  1611.      if( list[i]->entry_point && pattern == flag_combo(0,1,0) )
  1612.   continue;
  1613.  
  1614.      if(flag_combo(list[i]->used_flag,list[i]->set_flag,
  1615.         list[i]->used_before_set) == pattern) {
  1616.    if(matches++ == 0)
  1617.       fprintf(list_fd,"\nVariables %s in module %s:\n",
  1618.     msg,mod_name);
  1619.    len = strlen(list[i]->name);
  1620.    col += len = (len <= 10? 10: len) + 9;
  1621.    if(col > 78) {
  1622.      fprintf(list_fd,"\n");
  1623.      col = len;
  1624.    }
  1625.    fprintf(list_fd,"%10s",list[i]->name);
  1626.     /* arg never used: tag with asterisk */
  1627.    fprintf(list_fd,"%-9s",
  1628.     list[i]->argument? (++unused_args,"*") : "" );
  1629.      }
  1630.  }
  1631.  if(unused_args > 0)
  1632.   fprintf(list_fd,"\n  * Dummy argument");
  1633.  if(matches > 0)
  1634.   fprintf(list_fd,"\n");
  1635. }
  1636.